New Star Software Collection/NSS_Collection.iso/3-004 ms visual basic pro 30/4.imz/4.IMA/OPENDB.FR_/OPENDB.bin

Text File | 1993-04-28 | 10KB | 371 lines

VERSION 2.00
Begin Form fOpenDB
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Open DataBase"
   ClientHeight    =   2160
   ClientLeft      =   2460
   ClientTop       =   3840
   ClientWidth     =   4395
   ControlBox      =   0   'False
   ForeColor       =   &H00C0C0C0&
   Height          =   2565
   Left            =   2400
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2119.728
   ScaleMode       =   0  'User
   ScaleWidth      =   4447.084
   Top             =   3495
   Width           =   4515
   Begin ComboBox cDBName
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   1680
      Sorted          =   -1  'True
      TabIndex        =   0
      Tag             =   "OL"
      Top             =   105
      Width           =   2655
   End
   Begin TextBox cDataBase
      BackColor       =   &H00FFFFFF&
      Height          =   285
      Left            =   1680
      TabIndex        =   1
      Tag             =   "OL"
      Top             =   465
      Width           =   2655
   End
   Begin TextBox cUserName
      BackColor       =   &H00FFFFFF&
      Height          =   285
      Left            =   1680
      TabIndex        =   2
      Tag             =   "OL"
      Top             =   825
      Width           =   2655
   End
   Begin TextBox cPassword
      BackColor       =   &H00FFFFFF&
      Height          =   285
      Left            =   1680
      PasswordChar    =   "*"
      TabIndex        =   3
      Tag             =   "OL"
      Top             =   1185
      Width           =   2655
   End
   Begin CommandButton OkayButton
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Open"
      Default         =   -1  'True
      Height          =   375
      Left            =   300
      TabIndex        =   4
      Top             =   1680
      Width           =   1575
   End
   Begin CommandButton CancelButton
      BackColor       =   &H00C0C0C0&
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   2460
      TabIndex        =   5
      Top             =   1680
      Width           =   1575
   End
   Begin Label DataBaseLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "DataBase:"
      Height          =   255
      Left            =   120
      TabIndex        =   9
      Top             =   465
      Width           =   1335
   End
   Begin Label DBNameLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Source/Server:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   105
      Width           =   1470
   End
   Begin Label UserNameLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "User ID:"
      Height          =   255
      Left            =   120
      TabIndex        =   7
      Top             =   825
      Width           =   1335
   End
   Begin Label PasswordLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Password:"
      Height          =   255
      Left            =   120
      TabIndex        =   8
      Top             =   1170
      Width           =   1335
   End
End
Option Explicit

Dim BeenLoaded As Integer

'ODBC.DLL APIs
Declare Function SQLAllocEnv Lib "odbc.dll" (env As Long) As Integer
Declare Function SQLDataSources Lib "ODBC.DLL" (ByVal henv As Long, ByVal fdir As Integer, ByVal szDSN As String, ByVal cbDSNMAx As Integer, pcbDSN As Integer, ByVal szDesc As String, ByVal cbDescMax As Integer, pcbDesc As Integer) As Integer

Sub CancelButton_Click ()
  gfDBOpenFlag = False
  Unload Me
End Sub

Sub cDBName_Click ()
  On Error Resume Next

  Dim tmp As String
  Dim x As Integer

  cDataBase = ""
  cUserName = ""
  cPassword = ""

  'get the database name if there is one
  tmp = String$(255, 32)
  x = OSGetPrivateProfileString(cDBName, "database", "", tmp, Len(tmp), "ODBC.INI")
  cDataBase = Mid$(tmp, 1, x)

  'get the last user name is there is one
  tmp = String$(255, 32)
  x = OSGetPrivateProfileString(cDBName, "lastuser", "", tmp, Len(tmp), "ODBC.INI")
  cUserName = Mid$(tmp, 1, x)

  cPassword = ""

  If cUserName <> "" Then
    cPassword.SetFocus
  Else
    cDataBase.SetFocus
  End If

End Sub

Sub Form_Load ()
  Left = (Screen.Width - Width) / 2
  Top = (Screen.Height - Height) / 2

  GetDataSources cDBName

  MsgBar "Enter DataBase Parameters", False

  BeenLoaded = True

End Sub

Sub Form_Paint ()
  Outlines Me
End Sub

Sub Form_Unload (Cancel As Integer)
  MsgBar "", False
End Sub

'
'this routine fills a list box with all available
'ODBC data sources found in ODBC.INI
'
Sub GetDataSources (listctrl As Control)
  Dim DataSource As String, Description As String
  Dim DataSourceLen As Integer, DescriptionLen As Integer
  Dim retcode As Integer
  Dim henv As Long

  If SQLAllocEnv(henv) <> -1 Then
    DataSource = String$(32, 32)
    Description = String$(255, 32)
    'get the first one
    retcode = SQLDataSources(henv, 2, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen)
    While retcode = 0 Or retcode = 1
      listctrl.AddItem Mid(DataSource, 1, DataSourceLen)
      DataSource = String$(32, 32)
      Description = String$(255, 32)
      'get all the others
      retcode = SQLDataSources(henv, 1, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen)
    Wend
  End If

End Sub

Sub OkayButton_Click ()
   Dim Connect As String, DataSource As String
   Dim x As Integer
   Dim st As String
   Dim i As Integer
   Dim s As String, t As String
   Dim dbq As String

   On Error GoTo OpenError

   MsgBar "Opening DataBase", True

   If VDMDI.PrefOpenOnStartup.Checked = True Then
     Me.Refresh
   End If

   SetHourglass Me

   'check for blank server name and clear other parms
   If cDBName = "" Then
     cDataBase = ""
     cUserName = ""
     cPassword = ""
   End If

   'build connect string
   Connect = "ODBC;"
   If cUserName <> "" Then
     Connect = Connect + "UID=" + cUserName + ";PWD=" + cPassword
   End If
   If cDataBase <> "" Then
     Connect = Connect + ";DATABASE=" + cDataBase
   End If

   'add login timeout
   Connect = Connect + ";LoginTimeout=" & glLoginTimeout

   DataSource = cDBName

   'save the values
   gstDBName = cDBName
   gstDatabase = cDataBase
   gstUserName = cUserName
   gstPassword = cPassword
   gstDataType = "ODBC"

   Me.Hide
   Set gCurrentDB = OpenDatabase(DataSource, False, False, Connect)
   If gfDBOpenFlag = True Then
     CloseAllDynasets
   End If
   gfTransPending = False
   VDMDI.ToolBar.Visible = True
   VDMDI.QueryBuilder.Visible = True
   VDMDI.TblAttach.Visible = False
   fSQL.CreateQueryDefbtn.Visible = False

   'process the connect string just in case the
   'values came from the ODBC dialogs
   t = gCurrentDB.Connect
   If InStr(t, "=") Then
     i = 1
     While i <= Len(t) + 1
       If Mid(t, i, 1) = ";" Or i = Len(t) + 1 Then
         If s <> "" And InStr(s, "=") > 0 Then
           Select Case Mid(s, 1, InStr(1, s, "=") - 1)
             Case "DSN"
               gstDBName = Mid(s, InStr(1, s, "=") + 1, Len(s))
             Case "DATABASE"
               gstDatabase = Mid(s, InStr(1, s, "=") + 1, Len(s))
             Case "DBQ"
               gstDatabase = Mid(s, InStr(1, s, "=") + 1, Len(s))
             Case "UID"
               gstUserName = Mid(s, InStr(1, s, "=") + 1, Len(s))
             Case "PWD"
               gstPassword = Mid(s, InStr(1, s, "=") + 1, Len(s))
              Case Else
               'nothing
           End Select
         End If
         s = ""
       Else
         s = s + Mid(t, i, 1)
       End If
       i = i + 1
     Wend
   End If

   cDBName = gstDBName
   cDataBase = gstDatabase
   cUserName = gstUserName
   cPassword = gstPassword

   x = OSWritePrivateProfileString(gstDBName, "Database", gstDatabase, "ODBC.INI")
   x = OSWritePrivateProfileString(gstDBName, "LastUser", gstUserName, "ODBC.INI")

   fTables.Caption = gstDBName + "." + gstDatabase
   gCurrentDB.QueryTimeout = glQueryTimeout

   'success
   gfDBOpenFlag = True

   ResetMouse Me
   Unload Me

   GoTo OkayEnd

OpenError:
   ResetMouse Me
   gfDBOpenFlag = False
   If cDBName <> "" Then
     If InStr(1, Error$, "Data source not found") > 0 Then
       Beep
       MsgBox "This DataBase has not been Registered, this will now be attempted for you!", 48
       cDataBase = ""
       cUserName = ""
       cPassword = ""
       If RegisterDB((cDBName)) = True Then
         MsgBox "'" + cDBName + "' has been Registered, proceed with Open.", 48
       End If
     ElseIf InStr(1, Error$, "Login failed") > 0 Then
       Beep
       MsgBox "Invalid Parameter(s), Please try again!", 48
     ElseIf InStr(1, Error$, "QueryTimeout property") > 0 Then
       If glQueryTimeout <> 5 Then
         Beep
         MsgBox "Query Timeout Could not be set, default will be used!", 48
       End If
       Resume Next
     Else
       ShowError
     End If
   End If

   MsgBar "Enter DataBase Parameters", False
   Me.Show MODAL
   Resume OkayEnd

OkayEnd:

End Sub

Function RegisterDB (dbname As String) As Integer
   On Error GoTo RDBErr

   Dim driver As String

   driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER)
   If driver <> DEFAULTDRIVER Then
     RegisterDatabase cDBName, driver, False, ""
   Else
     RegisterDatabase cDBName, driver, True, ""
   End If

   RegisterDB = True
   GoTo RDBEnd

RDBErr:
   RegisterDB = False
   Resume RDBEnd

RDBEnd:

End Function